home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / gnu / calc202a.lha / calc-2.02a / calc-sel.el < prev    next >
Lisp/Scheme  |  1993-06-01  |  26KB  |  868 lines
  1. ;; Calculator for GNU Emacs, part II [calc-sel.el]
  2. ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
  3. ;; Written by Dave Gillespie, daveg@synaptics.com.
  4.  
  5. ;; This file is part of GNU Emacs.
  6.  
  7. ;; GNU Emacs is distributed in the hope that it will be useful,
  8. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  9. ;; accepts responsibility to anyone for the consequences of using it
  10. ;; or for whether it serves any particular purpose or works at all,
  11. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  12. ;; License for full details.
  13.  
  14. ;; Everyone is granted permission to copy, modify and redistribute
  15. ;; GNU Emacs, but only under the conditions described in the
  16. ;; GNU Emacs General Public License.   A copy of this license is
  17. ;; supposed to have been given to you along with GNU Emacs so you
  18. ;; can know your rights and responsibilities.  It should be in a
  19. ;; file named COPYING.  Among other things, the copyright notice
  20. ;; and this notice must be preserved on all copies.
  21.  
  22.  
  23.  
  24. ;; This file is autoloaded from calc-ext.el.
  25. (require 'calc-ext)
  26.  
  27. (require 'calc-macs)
  28.  
  29. (defun calc-Need-calc-sel () nil)
  30.  
  31.  
  32. ;;; Selection commands.
  33.  
  34. (defun calc-select-here (num &optional once keep)
  35.   (interactive "P")
  36.   (calc-wrapper
  37.    (calc-prepare-selection)
  38.    (let ((found (calc-find-selected-part))
  39.      (entry calc-selection-cache-entry))
  40.      (or (and keep (nth 2 entry))
  41.      (progn
  42.        (if once (progn
  43.               (setq calc-keep-selection nil)
  44.               (message "(Selection will apply to next command only)")))
  45.        (calc-change-current-selection 
  46.         (if found
  47.         (if (and num (> (setq num (prefix-numeric-value num)) 0))
  48.             (progn
  49.               (while (and (>= (setq num (1- num)) 0)
  50.                   (not (eq found (car entry))))
  51.             (setq found (calc-find-assoc-parent-formula
  52.                      (car entry) found)))
  53.               found)
  54.           (calc-grow-assoc-formula (car entry) found))
  55.           (car entry)))))))
  56. )
  57.  
  58. (defun calc-select-once (num)
  59.   (interactive "P")
  60.   (calc-select-here num t)
  61. )
  62.  
  63. (defun calc-select-here-maybe (num)
  64.   (interactive "P")
  65.   (calc-select-here num nil t)
  66. )
  67.  
  68. (defun calc-select-once-maybe (num)
  69.   (interactive "P")
  70.   (calc-select-here num t t)
  71. )
  72.  
  73. (defun calc-select-additional ()
  74.   (interactive)
  75.   (calc-wrapper
  76.    (let (calc-keep-selection)
  77.      (calc-prepare-selection))
  78.    (let ((found (calc-find-selected-part))
  79.      (entry calc-selection-cache-entry))
  80.      (calc-change-current-selection
  81.       (if found
  82.       (let ((sel (nth 2 entry)))
  83.         (if sel
  84.         (progn
  85.           (while (not (or (eq sel (car entry))
  86.                   (calc-find-sub-formula sel found)))
  87.             (setq sel (calc-find-assoc-parent-formula
  88.                    (car entry) sel)))
  89.           sel)
  90.           (calc-grow-assoc-formula (car entry) found)))
  91.     (car entry)))))
  92. )
  93.  
  94. (defun calc-select-more (num)
  95.   (interactive "P")
  96.   (calc-wrapper
  97.    (calc-prepare-selection)
  98.    (let ((entry calc-selection-cache-entry))
  99.      (if (nth 2 entry)
  100.      (let ((sel (nth 2 entry)))
  101.        (while (and (not (eq sel (car entry)))
  102.                (>= (setq num (1- (prefix-numeric-value num))) 0))
  103.          (setq sel (calc-find-assoc-parent-formula (car entry) sel)))
  104.        (calc-change-current-selection sel))
  105.        (calc-select-here num))))
  106. )
  107.  
  108. (defun calc-select-less (num)
  109.   (interactive "p")
  110.   (calc-wrapper
  111.    (calc-prepare-selection)
  112.    (let ((found (calc-find-selected-part))
  113.      (entry calc-selection-cache-entry))
  114.      (calc-change-current-selection 
  115.       (and found
  116.        (let ((sel (nth 2 entry))
  117.          old index op)
  118.          (while (and sel
  119.              (not (eq sel found))
  120.              (>= (setq num (1- num)) 0))
  121.            (setq old sel
  122.              index (calc-find-sub-formula sel found))
  123.            (and (setq sel (and index (nth index old)))
  124.             calc-assoc-selections
  125.             (setq op (assq (car-safe sel) calc-assoc-ops))
  126.             (memq (car old) (nth index op))
  127.             (setq num (1+ num))))
  128.          sel)))))
  129. )
  130.  
  131. (defun calc-select-part (num)
  132.   (interactive "P")
  133.   (or num (setq num (- last-command-char ?0)))
  134.   (calc-wrapper
  135.    (calc-prepare-selection)
  136.    (let ((sel (calc-find-nth-part (or (nth 2 calc-selection-cache-entry)
  137.                       (car calc-selection-cache-entry))
  138.                   num)))
  139.      (if sel
  140.      (calc-change-current-selection sel)
  141.        (error "%d is not a valid sub-formula index" num))))
  142. )
  143.  
  144. (defun calc-find-nth-part (expr num)
  145.   (if (and calc-assoc-selections
  146.        (assq (car-safe expr) calc-assoc-ops))
  147.       (let (op)
  148.     (calc-find-nth-part-rec expr))
  149.     (if (eq (car-safe expr) 'intv)
  150.     (and (>= num 1) (<= num 2) (nth (1+ num) expr))
  151.       (and (not (Math-primp expr)) (>= num 1) (< num (length expr))
  152.        (nth num expr))))
  153. )
  154.  
  155. (defun calc-find-nth-part-rec (expr)   ; uses num, op
  156.   (or (if (and (setq op (assq (car-safe (nth 1 expr)) calc-assoc-ops))
  157.            (memq (car expr) (nth 1 op)))
  158.       (calc-find-nth-part-rec (nth 1 expr))
  159.     (and (= (setq num (1- num)) 0)
  160.          (nth 1 expr)))
  161.       (if (and (setq op (assq (car-safe (nth 2 expr)) calc-assoc-ops))
  162.            (memq (car expr) (nth 2 op)))
  163.       (calc-find-nth-part-rec (nth 2 expr))
  164.     (and (= (setq num (1- num)) 0)
  165.          (nth 2 expr))))
  166. )
  167.  
  168. (defun calc-select-next (num)
  169.   (interactive "p")
  170.   (if (< num 0)
  171.       (calc-select-previous (- num))
  172.     (calc-wrapper
  173.      (calc-prepare-selection)
  174.      (let* ((entry calc-selection-cache-entry)
  175.         (sel (nth 2 entry)))
  176.        (if sel
  177.        (progn
  178.          (while (>= (setq num (1- num)) 0)
  179.            (let* ((parent (calc-find-parent-formula (car entry) sel))
  180.              (p parent)
  181.              op)
  182.          (and (eq p t) (setq p nil))
  183.          (while (and (setq p (cdr p))
  184.                  (not (eq (car p) sel))))
  185.          (if (cdr p)
  186.              (setq sel (or (and calc-assoc-selections
  187.                     (setq op (assq (car-safe (nth 1 p))
  188.                                calc-assoc-ops))
  189.                     (memq (car parent) (nth 2 op))
  190.                     (nth 1 (nth 1 p)))
  191.                    (nth 1 p)))
  192.            (if (and calc-assoc-selections
  193.                 (setq op (assq (car-safe parent) calc-assoc-ops))
  194.                 (consp (setq p (calc-find-parent-formula
  195.                         (car entry) parent)))
  196.                 (eq (nth 1 p) parent)
  197.                 (memq (car p) (nth 1 op)))
  198.                (setq sel (nth 2 p))
  199.              (error "No \"next\" sub-formula")))))
  200.          (calc-change-current-selection sel))
  201.      (if (Math-primp (car entry))
  202.          (calc-change-current-selection (car entry))
  203.        (calc-select-part num))))))
  204. )
  205.  
  206. (defun calc-select-previous (num)
  207.   (interactive "p")
  208.   (if (< num 0)
  209.       (calc-select-next (- num))
  210.     (calc-wrapper
  211.      (calc-prepare-selection)
  212.      (let* ((entry calc-selection-cache-entry)
  213.         (sel (nth 2 entry)))
  214.        (if sel
  215.        (progn
  216.          (while (>= (setq num (1- num)) 0)
  217.            (let* ((parent (calc-find-parent-formula (car entry) sel))
  218.               (p (cdr-safe parent))
  219.               (prev nil)
  220.               op)
  221.          (if (eq (car-safe parent) 'intv) (setq p (cdr p)))
  222.          (while (and (not (eq (car p) sel))
  223.                  (setq prev (car p)
  224.                    p (cdr p))))
  225.          (if prev
  226.              (setq sel (or (and calc-assoc-selections
  227.                     (setq op (assq (car-safe prev)
  228.                                calc-assoc-ops))
  229.                     (memq (car parent) (nth 1 op))
  230.                     (nth 2 prev))
  231.                    prev))
  232.            (if (and calc-assoc-selections
  233.                 (setq op (assq (car-safe parent) calc-assoc-ops))
  234.                 (consp (setq p (calc-find-parent-formula
  235.                         (car entry) parent)))
  236.                 (eq (nth 2 p) parent)
  237.                 (memq (car p) (nth 2 op)))
  238.                (setq sel (nth 1 p))
  239.              (error "No \"previous\" sub-formula")))))
  240.          (calc-change-current-selection sel))
  241.      (if (Math-primp (car entry))
  242.          (calc-change-current-selection (car entry))
  243.        (let ((len (if (and calc-assoc-selections
  244.                    (assq (car (car entry)) calc-assoc-ops))
  245.               (let (op (num 0))
  246.                 (calc-find-nth-part-rec (car entry))
  247.                 (- 1 num))
  248.             (length (car entry)))))
  249.          (calc-select-part (- len num))))))))
  250. )
  251.  
  252. (defun calc-find-parent-formula (expr part)
  253.   (cond ((eq expr part) t)
  254.     ((Math-primp expr) nil)
  255.     (t
  256.      (let ((p expr) res)
  257.        (while (and (setq p (cdr p))
  258.                (not (setq res (calc-find-parent-formula
  259.                        (car p) part)))))
  260.        (and p
  261.         (if (eq res t) expr res)))))
  262. )
  263.  
  264.  
  265. (defun calc-find-assoc-parent-formula (expr part)
  266.   (calc-grow-assoc-formula expr (calc-find-parent-formula expr part))
  267. )
  268.  
  269. (defun calc-grow-assoc-formula (expr part)
  270.   (if calc-assoc-selections
  271.       (let ((op (assq (car-safe part) calc-assoc-ops)))
  272.     (if op
  273.         (let (new)
  274.           (while (and (consp (setq new (calc-find-parent-formula
  275.                         expr part)))
  276.               (memq (car new)
  277.                 (nth (calc-find-sub-formula new part) op)))
  278.         (setq part new))))
  279.     part)
  280.     part)
  281. )
  282.  
  283. (defun calc-find-sub-formula (expr part)
  284.   (cond ((eq expr part) t)
  285.     ((Math-primp expr) nil)
  286.     (t
  287.      (let ((num 1))
  288.        (while (and (setq expr (cdr expr))
  289.                (not (calc-find-sub-formula (car expr) part)))
  290.          (setq num (1+ num)))
  291.        (and expr num))))
  292. )
  293.  
  294. (defun calc-unselect (num)
  295.   (interactive "P")
  296.   (calc-wrapper
  297.    (calc-prepare-selection num)
  298.    (calc-change-current-selection nil))
  299. )
  300.  
  301. (defun calc-clear-selections ()
  302.   (interactive)
  303.   (calc-wrapper
  304.    (let ((limit (calc-stack-size))
  305.      (n 1))
  306.      (while (<= n limit)
  307.        (if (calc-top n 'sel)
  308.        (progn
  309.          (calc-prepare-selection n)
  310.          (calc-change-current-selection nil)))
  311.        (setq n (1+ n))))
  312.    (calc-clear-command-flag 'position-point))
  313. )
  314.  
  315. (defun calc-show-selections (arg)
  316.   (interactive "P")
  317.   (calc-wrapper
  318.    (calc-preserve-point)
  319.    (setq calc-show-selections (if arg
  320.                   (> (prefix-numeric-value arg) 0)
  321.                 (not calc-show-selections)))
  322.    (let ((p calc-stack))
  323.      (while (and p
  324.          (or (null (nth 2 (car p)))
  325.              (equal (car p) calc-selection-cache-entry)))
  326.        (setq p (cdr p)))
  327.      (or (and p
  328.           (let ((calc-selection-cache-default-entry
  329.              calc-selection-cache-entry))
  330.         (calc-do-refresh)))
  331.      (and calc-selection-cache-entry
  332.           (let ((sel (nth 2 calc-selection-cache-entry)))
  333.         (setcar (nthcdr 2 calc-selection-cache-entry) nil)
  334.         (calc-change-current-selection sel)))))
  335.    (message (if calc-show-selections
  336.         "Displaying only selected part of formulas"
  337.           "Displaying all but selected part of formulas")))
  338. )
  339.  
  340. (defun calc-preserve-point ()
  341.   (or (looking-at "\\.\n+\\'")
  342.       (progn
  343.     (setq calc-final-point-line (+ (count-lines (point-min) (point))
  344.                        (if (bolp) 1 0))
  345.           calc-final-point-column (current-column))
  346.     (calc-set-command-flag 'position-point)))
  347. )
  348.  
  349. (defun calc-enable-selections (arg)
  350.   (interactive "P")
  351.   (calc-wrapper
  352.    (calc-preserve-point)
  353.    (setq calc-use-selections (if arg
  354.                  (> (prefix-numeric-value arg) 0)
  355.                    (not calc-use-selections)))
  356.    (calc-set-command-flag 'renum-stack)
  357.    (message (if calc-use-selections
  358.         "Commands operate only on selected sub-formulas"
  359.           "Selections of sub-formulas have no effect")))
  360. )
  361.  
  362. (defun calc-break-selections (arg)
  363.   (interactive "P")
  364.   (calc-wrapper
  365.    (calc-preserve-point)
  366.    (setq calc-assoc-selections (if arg
  367.                    (<= (prefix-numeric-value arg) 0)
  368.                  (not calc-assoc-selections)))
  369.    (message (if calc-assoc-selections
  370.         "Selection treats a+b+c as a sum of three terms"
  371.           "Selection treats a+b+c as (a+b)+c")))
  372. )
  373.  
  374. (defun calc-prepare-selection (&optional num)
  375.   (or num (setq num (calc-locate-cursor-element (point))))
  376.   (setq calc-selection-true-num num
  377.     calc-keep-selection t)
  378.   (or (> num 0) (setq num 1))
  379.   ;; (if (or (< num 1) (> num (calc-stack-size)))
  380.   ;;     (error "Cursor must be positioned on a stack element"))
  381.   (let* ((entry (calc-top num 'entry))
  382.      ww w)
  383.     (or (equal entry calc-selection-cache-entry)
  384.     (progn
  385.       (setcar entry (calc-encase-atoms (car entry)))
  386.       (setq calc-selection-cache-entry entry
  387.         calc-selection-cache-num num
  388.         calc-selection-cache-comp
  389.         (let ((math-comp-tagged t))
  390.           (math-compose-expr (car entry) 0))
  391.         calc-selection-cache-offset
  392.         (+ (car (math-stack-value-offset calc-selection-cache-comp))
  393.            (length calc-left-label)
  394.            (if calc-line-numbering 4 0))))))
  395.   (calc-preserve-point)
  396. )
  397. (setq calc-selection-cache-entry nil)
  398.  
  399. ;;; The following ensures that no two subformulas will be "eq" to each other!
  400. (defun calc-encase-atoms (x)
  401.   (if (or (not (consp x))
  402.       (equal x '(float 0 0)))
  403.       (list 'cplx x 0)
  404.     (calc-encase-atoms-rec x)
  405.     x)
  406. )
  407.  
  408. (defun calc-encase-atoms-rec (x)
  409.   (or (Math-primp x)
  410.       (progn
  411.     (if (eq (car x) 'intv)
  412.         (setq x (cdr x)))
  413.     (while (setq x (cdr x))
  414.       (if (or (not (consp (car x)))
  415.           (equal (car x) '(float 0 0)))
  416.           (setcar x (list 'cplx (car x) 0))
  417.         (calc-encase-atoms-rec (car x))))))
  418. )
  419.  
  420. (defun calc-find-selected-part ()
  421.   (let* ((math-comp-sel-hpos (- (current-column) calc-selection-cache-offset))
  422.      toppt
  423.      (lcount 0)
  424.      (spaces 0)
  425.      (math-comp-sel-vpos (save-excursion
  426.                    (beginning-of-line)
  427.                    (let ((line (point)))
  428.                  (calc-cursor-stack-index
  429.                   calc-selection-cache-num)
  430.                  (setq toppt (point))
  431.                  (while (< (point) line)
  432.                    (forward-line 1)
  433.                    (setq spaces (+ spaces
  434.                            (current-indentation))
  435.                      lcount (1+ lcount)))
  436.                  (- lcount (math-comp-ascent
  437.                         calc-selection-cache-comp) -1))))
  438.      (math-comp-sel-cpos (- (point) toppt calc-selection-cache-offset
  439.                 spaces lcount))
  440.      (math-comp-sel-tag nil))
  441.     (and (>= math-comp-sel-hpos 0)
  442.      (> calc-selection-true-num 0)
  443.      (math-composition-to-string calc-selection-cache-comp 1000000))
  444.     (nth 1 math-comp-sel-tag))
  445. )
  446.  
  447. (defun calc-change-current-selection (sub-expr)
  448.   (or (eq sub-expr (nth 2 calc-selection-cache-entry))
  449.       (let ((calc-prepared-composition calc-selection-cache-comp)
  450.         (buffer-read-only nil)
  451.         top)
  452.     (calc-set-command-flag 'renum-stack)
  453.     (setcar (nthcdr 2 calc-selection-cache-entry) sub-expr)
  454.     (calc-cursor-stack-index calc-selection-cache-num)
  455.     (setq top (point))
  456.     (calc-cursor-stack-index (1- calc-selection-cache-num))
  457.     (delete-region top (point))
  458.     (let ((calc-selection-cache-default-entry calc-selection-cache-entry))
  459.       (insert (math-format-stack-value calc-selection-cache-entry)
  460.           "\n"))))
  461. )
  462.  
  463. (defun calc-top-selected (&optional n m)
  464.   (and calc-any-selections
  465.        calc-use-selections
  466.        (progn
  467.      (or n (setq n 1))
  468.      (or m (setq m 1))
  469.      (calc-check-stack (+ n m -1))
  470.      (let ((top (nthcdr (+ m calc-stack-top -1) calc-stack))
  471.            (sel nil))
  472.        (while (>= (setq n (1- n)) 0)
  473.          (if (nth 2 (car top))
  474.          (setq sel (if sel t (nth 2 (car top)))))
  475.          (setq top (cdr top)))
  476.        sel)))
  477. )
  478.  
  479. (defun calc-replace-sub-formula (expr old new)
  480.   (setq new (calc-encase-atoms new))
  481.   (calc-replace-sub-formula-rec expr)
  482. )
  483.  
  484. (defun calc-replace-sub-formula-rec (expr)
  485.   (cond ((eq expr old) new)
  486.     ((Math-primp expr) expr)
  487.     (t
  488.      (cons (car expr)
  489.            (mapcar 'calc-replace-sub-formula-rec (cdr expr)))))
  490. )
  491.  
  492. (defun calc-sel-error ()
  493.   (error "Illegal operation on sub-formulas")
  494. )
  495.  
  496. (defun calc-replace-selections (n vals m)
  497.   (if (calc-top-selected n m)
  498.       (let ((num (length vals)))
  499.     (calc-preserve-point)
  500.     (cond
  501.      ((= n num)
  502.       (let* ((old (calc-top-list n m 'entry))
  503.          (new nil)
  504.          (sel nil)
  505.          val)
  506.         (while old
  507.           (if (nth 2 (car old))
  508.           (setq val (calc-encase-atoms (car vals))
  509.             new (cons (calc-replace-sub-formula (car (car old))
  510.                                 (nth 2 (car old))
  511.                                 val)
  512.                   new)
  513.             sel (cons val sel))
  514.         (setq new (cons (car vals) new)
  515.               sel (cons nil sel)))
  516.           (setq vals (cdr vals)
  517.             old (cdr old)))
  518.         (calc-pop-stack n m t)
  519.         (calc-push-list (nreverse new)
  520.                 m (and calc-keep-selection (nreverse sel)))))
  521.      ((= num 1)
  522.       (let* ((old (calc-top-list n m 'entry))
  523.          more)
  524.         (while (and old (not (nth 2 (car old))))
  525.           (setq old (cdr old)))
  526.         (setq more old)
  527.         (while (and (setq more (cdr more)) (not (nth 2 (car more)))))
  528.         (and more
  529.          (calc-sel-error))
  530.         (calc-pop-stack n m t)
  531.         (if old
  532.         (let ((val (calc-encase-atoms (car vals))))
  533.           (calc-push-list (list (calc-replace-sub-formula
  534.                      (car (car old))
  535.                      (nth 2 (car old))
  536.                      val))
  537.                   m (and calc-keep-selection (list val))))
  538.           (calc-push-list vals))))
  539.      (t (calc-sel-error))))
  540.     (calc-pop-stack n m t)
  541.     (calc-push-list vals m))
  542. )
  543. (setq calc-keep-selection t)
  544.  
  545. (defun calc-delete-selection (n)
  546.   (let ((entry (calc-top n 'entry)))
  547.     (if (nth 2 entry)
  548.     (if (eq (nth 2 entry) (car entry))
  549.         (progn
  550.           (calc-pop-stack 1 n t)
  551.           (calc-push-list '(0) n))
  552.       (let ((parent (calc-find-parent-formula (car entry) (nth 2 entry)))
  553.         (repl nil))
  554.         (calc-preserve-point)
  555.         (calc-pop-stack 1 n t)
  556.         (cond ((or (memq (car parent) '(* / %))
  557.                (and (eq (car parent) '^)
  558.                 (eq (nth 2 parent) (nth 2 entry))))
  559.            (setq repl 1))
  560.           ((memq (car parent) '(vec calcFunc-min calcFunc-max)))
  561.           ((and (assq (car parent) calc-tweak-eqn-table)
  562.             (= (length parent) 3))
  563.            (setq repl 'del))
  564.           (t
  565.            (setq repl 0)))
  566.         (cond
  567.          ((eq repl 'del)
  568.           (calc-push-list (list
  569.                    (calc-normalize
  570.                 (calc-replace-sub-formula
  571.                  (car entry)
  572.                  parent
  573.                  (if (eq (nth 2 entry) (nth 1 parent))
  574.                      (nth 2 parent)
  575.                    (nth 1 parent)))))
  576.                   n))
  577.          (repl
  578.           (calc-push-list (list
  579.                    (calc-normalize
  580.                 (calc-replace-sub-formula (car entry)
  581.                               (nth 2 entry)
  582.                               repl)))
  583.                   n))
  584.          (t
  585.           (calc-push-list (list
  586.                    (calc-normalize
  587.                 (calc-replace-sub-formula (car entry)
  588.                               parent
  589.                               (delq (nth 2 entry)
  590.                                 (copy-sequence
  591.                                  parent)))))
  592.                   n)))))
  593.       (calc-pop-stack 1 n t)))
  594. )
  595.  
  596. (defun calc-roll-down-with-selections (n m)
  597.   (let ((vals (append (calc-top-list m 1)
  598.               (calc-top-list (- n m) (1+ m))))
  599.     (sels (append (calc-top-list m 1 'sel)
  600.               (calc-top-list (- n m) (1+ m) 'sel))))
  601.     (calc-pop-push-list n vals 1 sels))
  602. )
  603.  
  604. (defun calc-roll-up-with-selections (n m)
  605.   (let ((vals (append (calc-top-list (- n m) 1)
  606.               (calc-top-list m (- n m -1))))
  607.     (sels (append (calc-top-list (- n m) 1 'sel)
  608.               (calc-top-list m (- n m -1) 'sel))))
  609.     (calc-pop-push-list n vals 1 sels))
  610. )
  611.  
  612. (defun calc-auto-selection (entry)
  613.   (or (nth 2 entry)
  614.       (progn
  615.     (and (boundp 'reselect) (setq reselect nil))
  616.     (calc-prepare-selection)
  617.     (calc-grow-assoc-formula (car entry) (calc-find-selected-part))))
  618. )
  619.  
  620. (defun calc-copy-selection ()
  621.   (interactive)
  622.   (calc-wrapper
  623.    (calc-preserve-point)
  624.    (let* ((num (max 1 (calc-locate-cursor-element (point))))
  625.       (entry (calc-top num 'entry)))
  626.      (calc-push (or (calc-auto-selection entry) (car entry)))))
  627. )
  628.  
  629. (defun calc-del-selection ()
  630.   (interactive)
  631.   (calc-wrapper
  632.    (calc-preserve-point)
  633.    (let* ((num (max 1 (calc-locate-cursor-element (point))))
  634.       (entry (calc-top num 'entry))
  635.       (sel (calc-auto-selection entry)))
  636.      (setcar (nthcdr 2 entry) (and (not (eq sel (car entry))) sel))
  637.      (calc-delete-selection num)))
  638. )
  639.  
  640. (defun calc-enter-selection ()
  641.   (interactive)
  642.   (calc-wrapper
  643.    (calc-preserve-point)
  644.    (let* ((num (max 1 (calc-locate-cursor-element (point))))
  645.       (reselect calc-keep-selection)
  646.       (entry (calc-top num 'entry))
  647.       (expr (car entry))
  648.       (sel (or (calc-auto-selection entry) expr))
  649.       alg)
  650.      (let ((calc-dollar-values (list sel))
  651.        (calc-dollar-used 0))
  652.        (setq alg (calc-do-alg-entry "" "Replace selection with: "))
  653.        (and alg
  654.         (progn
  655.           (setq alg (calc-encase-atoms (car alg)))
  656.           (calc-pop-push-record-list 1 "repl"
  657.                      (list (calc-replace-sub-formula
  658.                         expr sel alg))
  659.                      num
  660.                      (list (and reselect alg))))))
  661.      (calc-handle-whys)))
  662. )
  663.  
  664. (defun calc-edit-selection ()
  665.   (interactive)
  666.   (calc-wrapper
  667.    (calc-preserve-point)
  668.    (let* ((num (max 1 (calc-locate-cursor-element (point))))
  669.       (reselect calc-keep-selection)
  670.       (entry (calc-top num 'entry))
  671.       (expr (car entry))
  672.       (sel (or (calc-auto-selection entry) expr))
  673.       alg)
  674.      (let ((str (math-showing-full-precision
  675.          (math-format-nice-expr sel (screen-width)))))
  676.        (calc-edit-mode (list 'calc-finish-selection-edit
  677.                  num (list 'quote sel) reselect))
  678.        (insert str "\n"))))
  679.   (calc-show-edit-buffer)
  680. )
  681.  
  682. (defun calc-finish-selection-edit (num sel reselect)
  683.   (let ((buf (current-buffer))
  684.     (str (buffer-substring (point) (point-max)))
  685.     (start (point)))
  686.     (switch-to-buffer calc-original-buffer)
  687.     (let ((val (math-read-expr str)))
  688.       (if (eq (car-safe val) 'error)
  689.       (progn
  690.         (switch-to-buffer buf)
  691.         (goto-char (+ start (nth 1 val)))
  692.         (error (nth 2 val))))
  693.       (calc-wrapper
  694.        (calc-preserve-point)
  695.        (if disp-trail
  696.        (calc-trail-display 1 t))
  697.        (setq val (calc-encase-atoms (calc-normalize val)))
  698.        (let ((expr (calc-top num 'full)))
  699.      (if (calc-find-sub-formula expr sel)
  700.          (calc-pop-push-record-list 1 "edit"
  701.                     (list (calc-replace-sub-formula
  702.                            expr sel val))
  703.                     num
  704.                     (list (and reselect val)))
  705.        (calc-push val)
  706.        (error "Original selection has been lost"))))))
  707. )
  708.  
  709. (defun calc-sel-evaluate (arg)
  710.   (interactive "p")
  711.   (calc-slow-wrapper
  712.    (calc-preserve-point)
  713.    (let* ((num (max 1 (calc-locate-cursor-element (point))))
  714.       (reselect calc-keep-selection)
  715.       (entry (calc-top num 'entry))
  716.       (sel (or (calc-auto-selection entry) (car entry))))
  717.      (calc-with-default-simplification
  718.       (let ((math-simplify-only nil))
  719.     (calc-modify-simplify-mode arg)
  720.     (let ((val (calc-encase-atoms (calc-normalize sel))))
  721.       (calc-pop-push-record-list 1 "jsmp"
  722.                      (list (calc-replace-sub-formula
  723.                         (car entry) sel val))
  724.                      num
  725.                      (list (and reselect val))))))
  726.      (calc-handle-whys)))
  727. )
  728.  
  729. (defun calc-sel-expand-formula (arg)
  730.   (interactive "p")
  731.   (calc-slow-wrapper
  732.    (calc-preserve-point)
  733.    (let* ((num (max 1 (calc-locate-cursor-element (point))))
  734.       (reselect calc-keep-selection)
  735.       (entry (calc-top num 'entry))
  736.       (sel (or (calc-auto-selection entry) (car entry))))
  737.      (calc-with-default-simplification
  738.       (let ((math-simplify-only nil))
  739.     (calc-modify-simplify-mode arg)
  740.     (let* ((math-expand-formulas (> arg 0))
  741.            (val (calc-normalize sel))
  742.            top)
  743.       (and (<= arg 0)
  744.            (setq top (math-expand-formula val))
  745.            (setq val (calc-normalize top)))
  746.       (setq val (calc-encase-atoms val))
  747.       (calc-pop-push-record-list 1 "jexf"
  748.                      (list (calc-replace-sub-formula
  749.                         (car entry) sel val))
  750.                      num
  751.                      (list (and reselect val))))))
  752.      (calc-handle-whys)))
  753. )
  754.  
  755. (defun calc-sel-mult-both-sides (no-simp &optional divide)
  756.   (interactive "P")
  757.   (calc-wrapper
  758.    (calc-preserve-point)
  759.    (let* ((num (max 1 (calc-locate-cursor-element (point))))
  760.       (reselect calc-keep-selection)
  761.       (entry (calc-top num 'entry))
  762.       (expr (car entry))
  763.       (sel (or (calc-auto-selection entry) expr))
  764.       (func (car-safe sel))
  765.       alg lhs rhs)
  766.      (setq alg (calc-with-default-simplification
  767.         (car (calc-do-alg-entry ""
  768.                     (if divide
  769.                         "Divide both sides by: "
  770.                       "Multiply both sides by: ")))))
  771.      (and alg
  772.       (progn
  773.         (if (and (or (eq func '/)
  774.              (assq func calc-tweak-eqn-table))
  775.              (= (length sel) 3))
  776.         (progn
  777.           (or (memq func '(/ calcFunc-eq calcFunc-neq))
  778.               (if (math-known-nonposp alg)
  779.               (progn
  780.                 (setq func (nth 1 (assq func
  781.                             calc-tweak-eqn-table)))
  782.                 (or (math-known-negp alg)
  783.                 (message "Assuming this factor is nonzero")))
  784.             (or (math-known-posp alg)
  785.                 (if (math-known-nonnegp alg)
  786.                 (message "Assuming this factor is nonzero")
  787.                   (message "Assuming this factor is positive")))))
  788.           (setq lhs (list (if divide '/ '*) (nth 1 sel) alg)
  789.             rhs (list (if divide '/ '*) (nth 2 sel) alg))
  790.           (or no-simp
  791.               (progn
  792.             (setq lhs (math-simplify lhs)
  793.                   rhs (math-simplify rhs))
  794.             (and (eq func '/)
  795.                  (or (Math-equal (nth 1 sel) 1)
  796.                  (Math-equal (nth 1 sel) -1)
  797.                  (and (memq (car-safe (nth 2 sel)) '(+ -))
  798.                       (memq (car-safe alg) '(+ -))))
  799.                  (setq rhs (math-expand-term rhs)))))
  800.           (setq alg (calc-encase-atoms
  801.                  (calc-normalize (list func lhs rhs)))))
  802.           (setq rhs (list (if divide '* '/) sel alg))
  803.           (or no-simp
  804.           (setq rhs (math-simplify rhs)))
  805.           (setq alg (calc-encase-atoms
  806.              (calc-normalize (if divide
  807.                          (list '/ rhs alg)
  808.                        (list '* alg rhs))))))
  809.         (calc-pop-push-record-list 1 (if divide "div" "mult")
  810.                        (list (calc-replace-sub-formula
  811.                           expr sel alg))
  812.                        num
  813.                        (list (and reselect alg)))))
  814.      (calc-handle-whys)))
  815. )
  816.  
  817. (defun calc-sel-div-both-sides (no-simp)
  818.   (interactive "P")
  819.   (calc-sel-mult-both-sides no-simp t)
  820. )
  821.  
  822. (defun calc-sel-add-both-sides (no-simp &optional subtract)
  823.   (interactive "P")
  824.   (calc-wrapper
  825.    (calc-preserve-point)
  826.    (let* ((num (max 1 (calc-locate-cursor-element (point))))
  827.       (reselect calc-keep-selection)
  828.       (entry (calc-top num 'entry))
  829.       (expr (car entry))
  830.       (sel (or (calc-auto-selection entry) expr))
  831.       (func (car-safe sel))
  832.       alg lhs rhs)
  833.      (setq alg (calc-with-default-simplification
  834.         (car (calc-do-alg-entry ""
  835.                     (if subtract
  836.                         "Subtract from both sides: "
  837.                       "Add to both sides: ")))))
  838.      (and alg
  839.       (progn
  840.         (if (and (assq func calc-tweak-eqn-table)
  841.              (= (length sel) 3))
  842.         (progn
  843.           (setq lhs (list (if subtract '- '+) (nth 1 sel) alg)
  844.             rhs (list (if subtract '- '+) (nth 2 sel) alg))
  845.           (or no-simp
  846.               (setq lhs (math-simplify lhs)
  847.                 rhs (math-simplify rhs)))
  848.           (setq alg (calc-encase-atoms
  849.                  (calc-normalize (list func lhs rhs)))))
  850.           (setq rhs (list (if subtract '+ '-) sel alg))
  851.           (or no-simp
  852.           (setq rhs (math-simplify rhs)))
  853.           (setq alg (calc-encase-atoms
  854.              (calc-normalize (list (if subtract '- '+) alg rhs)))))
  855.         (calc-pop-push-record-list 1 (if subtract "sub" "add")
  856.                        (list (calc-replace-sub-formula
  857.                           expr sel alg))
  858.                        num
  859.                        (list (and reselect alg)))))
  860.      (calc-handle-whys)))
  861. )
  862.  
  863. (defun calc-sel-sub-both-sides (no-simp)
  864.   (interactive "P")
  865.   (calc-sel-add-both-sides no-simp t)
  866. )
  867.  
  868.